home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / unit-parser.scm < prev   
Encoding:
Text File  |  1994-09-27  |  8.1 KB  |  249 lines  |  [TEXT/CCL2]
  1. ;;;=====================================================================
  2. ;;; Compilation unit file parsing
  3. ;;;=====================================================================
  4.  
  5. ;;; This parses a unit file.  The file simply contains a list of file names.
  6. ;;; The files are sorted into two catagories: other compilation units and
  7. ;;; source files in the current unit.
  8.  
  9. ;;; The filename will always have a .hu extension at this point.  If an
  10. ;;; implicit unit is being used, this will create one if the .hu file does not
  11. ;;; exist but a source one does.
  12.  
  13. (define (parse-compilation-unit filename)
  14.   (if (file-exists? filename)
  15.       (if (interface-extension? (filename-type filename))
  16.       (create-implicit-interface-unit filename)
  17.       (parse-compilation-unit-aux
  18.        filename
  19.        (call-with-input-file filename (function gather-file-names))))
  20.       (create-implicit-unit filename)))
  21.  
  22. (define (create-implicit-unit filename)
  23.   (let ((source-file (locate-existing-source-file filename)))
  24.     (if source-file
  25.     (create-ucache filename source-file (list source-file)
  26.                '() '() '() '#f '#t
  27.                '#f '() '#f '() '#f
  28.                (file-write-date source-file))
  29.     (signal-files-not-found filename source-file))))
  30.  
  31. (define (signal-files-not-found unit-file source-file)
  32.   (fatal-error 'files-not-found
  33.     "Neither the unit file ~a nor source file ~a were found."
  34.     unit-file source-file))
  35.    
  36.  
  37. ;;; Actually parse contents of the unit file.
  38.  
  39. ;;; These are in the command-interface stuff.
  40. (predefine (set-printers args mode))
  41. (predefine (set-optimizers args mode))
  42. (predefine (parse-command-args string start next end))
  43.  
  44. (define (parse-compilation-unit-aux filename strings)
  45.   (let ((input-defaults   filename)
  46.     (output-defaults  filename)
  47.     (import-defaults  filename)
  48.     (stable?          '#f)
  49.     (load-prelude?    '#t)
  50.     (filenames        '())
  51.     (imports          '())
  52.     (sources          '())
  53.     (lisp-files       '())
  54.     (foreign-files    '())
  55.     (printers         '())
  56.     (printers-set?    '#f)
  57.     (optimizers       '())
  58.     (optimizers-set?  '#f)
  59.     (chunk-size       '#f)
  60.     (temp             '#f)
  61.     (interfaces       '()))
  62.     ;;; First look for magic flags.
  63.     (dolist (s strings)
  64.       (cond ((setf temp (string-match-prefix ":input" s))
  65.          (setf input-defaults (merge-file-defaults temp filename)))
  66.         ((setf temp (string-match-prefix ":output" s))
  67.          (setf output-defaults (merge-file-defaults temp filename)))
  68.         ((setf temp (string-match-prefix ":import" s))
  69.          (setf import-defaults (merge-file-defaults temp filename)))
  70.         ((string=? ":stable" s)
  71.          (setf stable? '#t))
  72.         ((string=? ":prelude" s)
  73.          (setf load-prelude? '#f))
  74.         ((setf temp (string-match-prefix ":p=" s))
  75.          (setf printers-set? '#t)
  76.          (setf printers
  77.            (set-printers
  78.               (parse-command-args temp 0 0 (string-length temp))
  79.               '=)))
  80.         ((setf temp (string-match-prefix ":o=" s))
  81.          (setf optimizers-set? '#t)
  82.          (setf optimizers
  83.            (set-optimizers
  84.                       (parse-command-args temp 0 0 (string-length temp))
  85.               '=)))
  86.         ((setf temp (string-match-prefix ":chunk-size" s))
  87.          (setf chunk-size (string->number temp)))
  88.         (else
  89.          (push s filenames))))
  90.     ;;; Next sort filenames into imports and source files.
  91.     (dolist (s filenames)
  92.       (let ((type    (filename-type s))
  93.         (fname   '#f))
  94.     (cond ((string=? type "")  ; punt for now on this issue
  95.            (signal-extension-needed s))
  96.           ((unit-extension? type)
  97.            (setf fname  (merge-file-defaults s import-defaults))
  98.            (if (file-exists? fname)
  99.            (push fname imports)
  100.            (signal-unit-not-found fname)))
  101.           ((source-extension? type)
  102.            (setf fname  (merge-file-defaults s input-defaults))
  103.            (if (file-exists? fname)
  104.            (push fname sources)
  105.            (signal-unit-not-found fname)))
  106.           ((interface-extension? type)
  107.            (setf fname  (merge-file-defaults s input-defaults))
  108.            (if (file-exists? fname)
  109.            (push fname interfaces)
  110.            (signal-unit-not-found fname)))
  111.           ((lisp-extension? type)
  112.            (when (string=? (filename-name s) (filename-name filename))
  113.           (fatal-error 'bad-lisp-file-name
  114.     "Lisp file name ~A in unit ~A can not be the same as the unit name"
  115.                           s filename))
  116.            (setf fname (merge-file-defaults s input-defaults))
  117.            (if (file-exists? fname)
  118.            (push (cons fname
  119.                    (add-extension
  120.                      (merge-file-defaults s output-defaults)
  121.                  binary-file-type))
  122.              lisp-files)
  123.            (signal-unit-not-found fname)))
  124.           ((foreign-extension? type)
  125.            (setf fname (merge-file-defaults s input-defaults))
  126.            (if (file-exists? fname)
  127.            (push fname foreign-files)
  128.            (signal-unit-not-found fname)))
  129.           (else
  130.            (signal-unknown-file-type s)))))
  131.     ;; Add implicit units for .hi files
  132.     (if (and interfaces (null? (cdr interfaces)) (null? sources))
  133.     (setf sources interfaces) ;; Special case
  134.     (dolist (i interfaces)
  135.           (let ((u (create-implicit-interface-unit i)))
  136.         (push (ucache-ufile u) imports))))
  137.     ;; Finally create the unit object.
  138.     (create-ucache filename output-defaults
  139.            sources imports lisp-files foreign-files
  140.            stable? load-prelude?
  141.            printers-set? printers optimizers-set? optimizers
  142.            chunk-size (file-write-date filename))))
  143.  
  144. ;;; Create interface-units for implicit interfaces
  145.  
  146. (define (create-implicit-interface-unit name)
  147.   (let ((u (lookup-compiled-unit name)))
  148.     (or u
  149.     (let ((res (create-ucache name name  ; Should add suffix
  150.                   (list name) '() '() '()
  151.                   '#f '#f
  152.                   '#f '() '#f '()
  153.                   '#f (file-write-date name))))
  154.       (install-compilation-unit name res)
  155.       res))))
  156.  
  157. ;;; Helper functions for the above.
  158.  
  159. ;;; This returns a list of strings.  Blank lines and lines starting in -
  160. ;;; are ignored.
  161.  
  162. (define (gather-file-names port)
  163.   (let ((char (peek-char port)))
  164.     (cond ((eof-object? char)
  165.        '())
  166.       ((or (char=? char '#\newline) (char=? char '#\-))
  167.        (read-line port)
  168.        (gather-file-names port))
  169.       (else
  170.        (let ((line (read-line port)))
  171.          (cons line (gather-file-names port)))))))
  172.  
  173.  
  174. ;;; This has too many arguments!!
  175.  
  176. (define (create-ucache filename output-filename
  177.                source-files imports lisp-files foreign-files
  178.                stable? load-prelude?
  179.                printers-set? printers optimizers-set? optimizers
  180.                chunk-size udate)
  181.   (let* ((cifilename
  182.       (make-cifilename output-filename))
  183.      (sifilename
  184.       (make-sifilename output-filename))
  185.      (all-imports
  186.       (if load-prelude?
  187.           (cons *prelude-unit-filename* imports)
  188.           imports))
  189.      (cache-entry
  190.       (make ucache
  191.         (ufile filename)
  192.         (sifile sifilename)
  193.         (cifile cifilename)
  194.         (sfile (make-sfilename output-filename))
  195.         (cfile (make-cfilename output-filename))
  196.         (udate udate)
  197.         (stable? stable?)
  198.         (load-prelude? load-prelude?)
  199.         (ifile-loaded '#f)
  200.         (code-loaded '#f)
  201.         (code-compiled '#f)
  202.         (source-files source-files)
  203.         (imported-units all-imports)
  204.         (lisp-files lisp-files)
  205.         (foreign-files foreign-files)
  206.         (modules '())
  207.         (printers-set? printers-set?)
  208.         (printers printers)
  209.         (optimizers-set? optimizers-set?)
  210.         (optimizers optimizers)
  211.         (chunk-size chunk-size))))
  212.     (install-compilation-unit filename cache-entry)
  213.     cache-entry))
  214.  
  215. (define (string-match-prefix prefix s)
  216.   (let ((prefix-length  (string-length prefix))
  217.     (s-length       (string-length s)))
  218.     (if (>= s-length prefix-length)
  219.     (string-match-prefix-aux prefix s prefix-length s-length 0)
  220.     '#f)))
  221.  
  222. (define (string-match-prefix-aux prefix s prefix-length s-length i)
  223.   (cond ((eqv? i prefix-length)
  224.      (string-match-prefix-aux-aux s s-length i))
  225.     ((not (char=? (string-ref s i) (string-ref prefix i)))
  226.      '#f)
  227.     (else
  228.      (string-match-prefix-aux prefix s prefix-length s-length (1+ i)))))
  229.  
  230. (define (string-match-prefix-aux-aux s s-length i)
  231.   (cond ((eqv? i s-length)
  232.      "")
  233.     ((let ((ch  (string-ref s i)))
  234.        (or (char=? ch '#\space) (char=? ch #\tab)))
  235.      (string-match-prefix-aux-aux s s-length (1+ i)))
  236.     (else
  237.      (substring s i s-length))))
  238.  
  239. (define (merge-file-defaults filename defaults)
  240.   (let ((place  (filename-place filename))
  241.     (name   (filename-name filename))
  242.     (type   (filename-type filename)))
  243.     (assemble-filename
  244.       (if (string=? place "") defaults place)
  245.       (if (string=? name "") defaults name)
  246.       (if (string=? type "") defaults type))))
  247.     
  248.     
  249.